perm filename LCOM4.LSP[206,LSP]1 blob
sn#306069 filedate 1977-09-18 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 edit <cs206>lcom4.lsp
C00022 ENDMK
C⊗;
edit <cs206>lcom4.lsp
Edit: <CS206>LCOM4.LSP.2
*p1:*
00100 (DECLARE (SETQ NO-DISK-HACKS T))
00200 (DECLARE (READ))
00300
00400 (DEFPROP COMPFCNS
00500 (COMPFCNS COMPL
00600 COMP
00700 SUBSTACK
00800 PRUP
00900 MKPUSH
01000 COMPEXP
01100 STACKUP
01200 CCCHAIN
01300 COMPC
01400 COMCOND
01500 COMPLISA
01600 CCOUNT
01700 LOADAC
01800 COMPLIS
01900 CLASSIFY
π
02000 CLASS1
02100 CLASS2
02200 MKJRST
02300 COMBOOL
02400 COMPANDOR
02500 COMPANDOR1
02600 FLAT)
02700 VALUE)
02800
02900 (DEFUN FEXPR COMPL(FILE)
03000 (UWRITE)
03100 (APPLY ''EREAD FILE)
03200 (SELECT-DISK-INPUT (READ-UNTIL-EOF WITH Z DO
03300 (COND ((OR (EQ (CAR Z) (QUOTE DEFUN))
03400 (AND (EQ (CAR Z) (QUOTE DEFPROP))
03500 (EQ (CADDDR Z) (QUOTE EXPR))))
03600 (PROG (PROG)
03700 (SETQ PROG
03800 (COND ((EQ (CAR Z) (QUOTE DEFUN))
03900 (COMP (CADR Z)
π
04000 (CADDR Z)
04100 (CADDDR Z)))
04200 (T
04300 (COMP (CADR Z)
04400 (CADR (CADDR Z))
04500 (CADDR (CADDR Z))))))
04600 (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION P
RINT) PROG)))
04700 (PRINT (LIST (CADR Z) (LENGTH PROG)))))
04800 (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
04900 (APPLY ''UFILE (LIST (CAR FILE) ''LAP))
05000 (QUOTE ENDCOMP)))
05100
05200
05300 (DEFUN COMP(FN VARS EXP)
05400 ((LAMBDA(VPR N)
05500 (FLAT (LIST (LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
05600 (MKPUSH N 1)
05700 (COMPEXP EXP (MINUS N) VPR)
05800 (SUBSTACK N)
π
05900 (QUOTE ((POPJ P) (LABEL NIL))))
06000 NIL))
06100 (PRUP VARS 1)
06200 (LENGTH VARS)))
06300
06400 (DEFUN SUBSTACK(N)
06500 (COND ((= N 0) NIL)
06600 (T
06700 (LIST
06800 (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N))))))
06900
07000 (DEFUN PRUP(VARS N)
07100 (COND ((NULL VARS) NIL)
07200 (T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (ADD1 N))))))
07300
07400 (DEFUN MKPUSH(N M)
07500 (COND ((LESSP N M) NIL)
07600 (T
07700 (CONS (LIST (QUOTE PUSH) (QUOTE P) M)
07800 (MKPUSH N (ADD1 M))))))
π
07900
08000 (DEFUN COMPEXP(EXP M VPR)
08100 (COND ((NULL EXP) (QUOTE ((MOVEI 1 0))))
08200 ((OR (EQ EXP (QUOTE T)) (NUMBERP EXP))
08300 (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
08400 ((ATOM EXP)
08500 (LIST
08600 (LIST (QUOTE MOVE)
08700 1
08800 (PLUS M (CDR (ASSOC EXP VPR)))
08900 (QUOTE P))))
09000 ((EQ (CAR EXP) (QUOTE CAR))
09100 (COND ((ATOM (CADR EXP))
09200 (LIST
09300 (LIST (QUOTE HLRZ@)
09400 1
09500 (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
09600 (QUOTE P))))
09700 (T
09800 (LIST (COMPEXP (CADR EXP) M VPR)
π
09900 (QUOTE ((HLRZ@ 1 1)))))))
10000 ((EQ (CAR EXP) (QUOTE CDR))
10100 (COND ((ATOM (CADR EXP))
10200 (LIST
10300 (LIST (QUOTE HRRZ@)
10400 1
10500 (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
10600 (QUOTE P))))
10700 (T
10800 (LIST (COMPEXP (CADR EXP) M VPR)
10900 (QUOTE ((HRRZ@ 1 1)))))))
11000 ((OR (EQ (CAR EXP) (QUOTE AND))
11100 (EQ (CAR EXP) (QUOTE OR))
11200 (EQ (CAR EXP) (QUOTE NOT))
11300 (EQ (CAR EXP) (QUOTE EQ)))
11400 ((LAMBDA(L1 L2)
11500 (LIST (COMBOOL EXP M L1 NIL VPR)
11600 (LIST (QUOTE (MOVEI 1 (QUOTE T)))
11700 (LIST (QUOTE JRST) 0 L2)
11800 (LIST (QUOTE LABEL) L1)
π
11900 (QUOTE (MOVEI 1 0))
12000 (LIST (QUOTE LABEL) L2))))
12100 (GENSYM)
12200 (GENSYM)))
12300 ((EQ (CAR EXP) (QUOTE COND))
12400 (COMCOND (CDR EXP) M (GENSYM) VPR))
12500 ((EQ (CAR EXP) (QUOTE QUOTE))
12600 (LIST (LIST (QUOTE MOVEI) 1 EXP)))
12700 ((ATOM (CAR EXP))
12800 (LIST (COMPLISA (CDR EXP) M VPR)
12900 (LIST
13000 (LIST (QUOTE CALL)
13100 (LENGTH (CDR EXP))
13200 (LIST ''QUOTE (CAR EXP))
13300 ))))
13400 ((EQ (CAAR EXP) (QUOTE LAMBDA))
13500 ((LAMBDA(N)
13600 (LIST (STACKUP (CDR EXP) M VPR)
13700 (COMPEXP
13800 (CADDAR EXP)
π
13900 (DIFFERENCE M N)
14000 (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR)) ;APE
ND?
14100 (SUBSTACK N)))
14200 (LENGTH (CDR EXP))))
14300 ((QUOTE T) (QUOTE NIL))))
14400
14500 (DEFUN STACKUP(U M VPR)
14600 (COND ((NULL U) NIL)
14700 (T
14800 (LIST (COMPEXP (CAR U) M VPR)
14900 (QUOTE ((PUSH P 1)))
15000 (STACKUP (CDR U) (SUB1 M) VPR)))))
15100
15200 (DEFUN CCCHAIN(EXP)
15300 (AND (OR (EQ (CAR EXP) (QUOTE CAR)) (EQ (CAR EXP) (QUOTE CDR)))
15400 (OR (ATOM (CADR EXP)) (CCCHAIN (CADR EXP)))))
15500
15600 (DEFUN COMPC(EXP N2 M VPR)
15700 (COND ((ATOM EXP) (ERROR (QUOTE COMPC)))
π
15800 ((EQ (CAR EXP) (QUOTE CAR))
15900 (COND ((ATOM (CADR EXP))
16000 (LIST
16100 (LIST (QUOTE HLRZ@)
16200 N2
16300 (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
16400 (QUOTE P))))
16500 (T
16600 (CONS (LIST (QUOTE HLRZ@) N2 N2)
16700 (COMPC (CADR EXP) N2 M VPR)))))
16800 ((ATOM (CADR EXP))
16900 (LIST
17000 (?IST (QUOTE HRRZ@)
17100 N2
17200 (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
17300 (QUOTE P))))
17400 (T
17500 (CONS (LIST (QUOTE HRRZ@) N2 N2)
17600 (COMPC (CADR EXP) N2 M VPR)))))
17700
π
17800 (DEFUN COMCOND(U M L VPR)
17900 (COND ((NULL U) (LIST (LIST (QUOTE LABEL) L)))
18000 ((AND (NOT (ATOM (CAAR U)))
18100 (EQ (CAAAR U) (QUOTE NULL))
18200 (NULL (CADAR U)))
18300 (LIST (COMPEXP (CADAAR U) M VPR)
18400 (LIST (LIST (QUOTE JUMPE) 1 L))
18500 (COMCOND (CDR U) M L VPR)))
18600 ((EQ (CAAR U) (QUOTE T))
18700 (LIST (COMPEXP (CADAR U) M VPR)
18800 (LIST (LIST (QUOTE LABEL) L))))
18900 (T
19000 ((LAMBDA(L1)
19100 (LIST (COMBOOL (CAAR U) M L1 NIL VPR)
19200 (COMPEXP (CADAR U) M VPR)
19300 (LIST (LIST (QUOTE JRST) 0 L)
19400 (LIST (QUOTE LABEL) L1))
19500 (COMCOND (CDR U) M L VPR)))
19600 (GENSYM)))))
19700
π
19800 (DEFUN COMPLISA(U M VPR)
19900 ((LAMBDA(Z)
20000 (LIST (COMPLIS Z M 1 VPR)
20100 (LOADAC Z
20200 (DIFFERENCE 1 (CCOUNT Z))
20300 1
20400 (DIFFERENCE M?(CCOUNT Z))
20500 VPR)
20600 (SUBSTACK (CCOUNT Z))))
20700 (CLASSIFY U)))
20800
20900 (DEFUN CCOUNT(Z)
21000 (COND ((NULL Z) 0)
21100 ((= (CAAR Z) 4) (ADD1(CCOUNT (CDR Z))))
21200 (T (CCOUNT (CDR Z)))))
21300
21400 (DEFUN LOADAC(Z M2 N2 M VPR)
21500 (COND ((NULL Z) NIL)
21600 ((= (CAAR Z) 1)
21700 (CONS (LIST (QUOTE MOVE)
π
21800 N2
21900 (PLUS M (CDR (ASSOC (CDAR Z) VPR)))
22000 (QUOTE P))
22100 (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
22200 ((= (CAAR Z) 0)
22300 (CONS (LIST (QUOTE MOVEI) N2 (LIST (QUOTE QUOTE) (CDAR Z)))
22400 (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
22500 ((= (CAAR Z) 2)
22600 (CONS (LIST (QUOTE MOVEI) N2 (CDAR Z))
22700 (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
22800 ((= (CAAR Z) 3)
22900 (LIST (REVERSE (COMPC (CDAR Z) N2 M VPR))
23000 (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
23100 ((= (CAAR Z) 5) (LOADAC (CDR Z) 1 (ADD1 N2) M VPR))
23200 (T
23300 (CONS (LIST (QUOTE MOVE) N2 M2 (QUOTE P))
23400 (LOADAC (CDR Z) (ADD1 M2) (ADD1 N2) M VPR)))))
23500
23600 (DEFUN COMPLIS(Z M K VPR)
23700 (COND ((NULL Z) NIL)
π
23800 ((= (CAAR Z) 4)
23900 (LIST (COMPEXP (CDAR Z) M VPR)
24000 (QUOTE ((PUSH P 1)))
24100 (COMPLIS (CDR Z) (SUB1 M) (ADD1 K) VPR)))
24200 ((= (CAAR Z) 5)
24300 (LIST (COMPEXP (CDAR Z) M VPR)
24400 (COND ((= K 1) NIL)
24500 (T (LIST (LIST (QUOTE MOVE) K 1))))))
24600 (T (COMPLIS (CDR Z) M (ADD1 K) VPR))))
24700
24800 (DEFUN CLASSIFY(U) (CLASS2 (CLASS1 U NIL) NIL T))
24900
25000 (DEFUN CLASS1(U V)
25100 (COND ((NULL U) V)
25200 ((ATOM (CAR U))
25300 (COND ((OR (EQUAL (CAR U) (QUOTE NIL))
25400 (EQUAL (CAR U) (QUOTE T))
25500 (NUMBERP (CAR U)))
25600 (CLASS1 (CDR U) (CONS (CONS 0 (CAR U)) V)))
25700 (T (CLASS1 (CDR U) (CONS (CONS 1 (CAR U)) V)))))
π
25800 ((EQUAL (CAAR U) (QUOTE QUOTE))
25900 (CLASS1 (CDR U) (CONS (CONS 2 (CAR U)) V)))
26000 ((CCCHAIN (CAR U))
26100 (CLASS1 (CDR U) (CONS (CONS 3 (CAR U)) V)))
26200 (T (CLASS1 (CDR U) (CONS (CONS 4 (CAR U)) V)))))
26300
26400 (DEFUN CLASS2(U V FLG)
26500 (COND ((NULL U) V)
26600 ((AND FLG (= (CAAR U) 4))
26700 (CLASS2 (CDR U) (CONS (CONS 5 (CDAR U)) V) NIL))
26800 (T (CLASS2 (CDR U) (CONS (CAR U) V) FLG))))
26900
27000 (DEFUN MKJRST(L) (LIST (LIST (QUOTE JRST) 0 L)))
27100
27200 (DEFUN COMBOOL(P M L FLG VPR)
27300 (COND ((EQ P (QUOTE T)) (COND (FLG (MKJRST L)) (T NIL)))
27400 ((ATOM P)
27500 (LIST (COMPEXP P M VPR)
27600 (LIST
27700 (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
π
27800 1
27900 L))))
28000 ((EQ (CAR P) (QUOTE EQ))
28100 (LIST (COMPLISA (CDR P) M VPR)
28200 (COND (FLG (QUOTE ((CAMN 1 2))))
28300 (T (QUOTE ((CAME 1 2)))))
28400 (MKJRST L)))
28500 ((EQ (CAR P) (QUOTE AND))
8600 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
28700 (T
28800 ((LAMBDA(L1)
28900 (LIST (COMPANDOR1 (CDR P) M L1 L NIL VPR)
29000 (LIST (LIST (QUOTE LABEL) L1))))
29100 (GENSYM)))))
29200 ((EQ (CAR P) (QUOTE OR))
29300 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
29400 (T
29500 ((LAMBDA(L1)
29600